Monster Media 1996 #15/Monster Media Number 15 (Monster Media)(July 1996).ISO/netmail/rnr214.zip/RNRIO.PAS

Pascal/Delphi Source File | 1996-01-30 | 15KB | 808 lines

unit rnrio;

{

rnrio.pas - nonconsole input/output routines

assumes a fossil (if the nonconsole routines will ever be used)

requires:

uses dos,crt,rnrglob,rnrmous ( , and possibly rnrtime ) ;

shortcomings:

minimal ansi/vt100 hard-coded in

}

{$I rnr-def.pas}

interface

uses dos,crt,genericf,rnrglob,rnrconf,rnrmous

{$ifdef timeout}

,rnrtime

{$endif}

{$ifdef mouse}

,mouse

{$endif}

;

const
  yespreserve=true;
  nopreserve=false;
  endkeysnospace=  #13#27#10;       { CR, ESC, LF             }
  endkeyswithspace=#13#27#10' '#9;  { CR, ESC, LF, SPACE, TAB }

procedure xwrites(s: string);
procedure xwritesw(s: string; w: integer);
procedure xwritei(i: integer);
procedure xwriteiw(i,w: integer);
procedure xwritess(s1,s2: string);
procedure xwritesss(s1,s2,s3: string);
procedure xwritessss(s1,s2,s3,s4: string);
procedure xwritesis(s1: string; i2: integer; s3: string);
procedure xwritessis(s1,s2: string; i3: integer; s4: string);
procedure xwriteln;
procedure xwritelns(s: string);
procedure xwritelnss(s1,s2: string);
procedure xwritelnsss(s1,s2,s3: string);
procedure xwritelnssss(s1,s2,s3,s4: string);
procedure xwritelnsi(s1: string; i2: integer);
{
procedure xwritelnsssisis(s1,s2,s3: string; i4: integer; s5: string;
 i6: integer; s7: string);
}
procedure xgotoxy(x,y: integer);
procedure writexy(x,y: integer; s: string);
procedure xclreol;
procedure xclreolxy(x,y: integer);
procedure xclrscr;
function xkeypressed: boolean;
function xreadkeyextended(forcecolumn: integer; forcerow: integer;
 beginrow, endrow: integer): char;
function xreadkey: char;
procedure xreadlnseh(var s: string; maxlen: integer; keepcurrent: boolean;
 endlist: string; readlnhistoryp: readlnhistorypt);
procedure xreadlnse(var s: string; maxlen: integer; keepcurrent: boolean;
 endlist: string);
procedure xreadlns(var s: string; maxlen: integer; keepcurrent: boolean);

procedure xsetcolor(color: byte);
procedure xhighvideo;
procedure xlowvideo;

{
procedure xquotevideo;
procedure xalternatevideo;
procedure xdatevideo;
}

procedure xwritehighlights(s: string);
procedure hwritexy(x,y: integer; s: string);

implementation

procedure noncwritec(c: char);

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 1;
  regs.al := ord(c);
  intr($14,regs);
end;

function noncreadc: char;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 2;
  intr($14,regs);
  noncreadc := chr(regs.al);
end;

function noncinready: boolean;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 3;
  intr($14,regs);
  noncinready := odd(regs.ah);
end;

procedure xwrites;

var
  i: integer;

begin
  if console then
    begin
      mousehide;
      write(s);
      mouseshow;
    end
  else
    begin
      for i := 1 to length(s) do
        noncwritec(s[i]);
      if shadow>0 then
        begin
          write(s);
          delay(shadow);
        end;
    end;
end;

procedure xwritesw;

var
  paddeds: string;
  i: integer;

begin
  paddeds := s;
  for i := 1 to w-length(s) do
    paddeds := ' '+paddeds;
  xwrites(paddeds);
end;

procedure xwritei;

var
  s: string;

begin
{
  if console then
    begin
      mousehide;
      write(i);
      mouseshow;
    end
  else
    begin
}
      str(i,s);
      xwrites(s);
{
    end;
}
end;

procedure xwriteiw;

var
  s: string;

begin
{
  if console then
    begin
      mousehide;
      write(i:w);
      mouseshow;
    end
  else
    begin
      str(i:w,s);
      xwrites(s);
    end;
}
  str(i,s);
  xwritesw(s,w);
end;

procedure xwritess;

begin
  xwrites(s1);
  xwrites(s2);
end;

procedure xwritesss;

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
end;

procedure xwritessss;

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
  xwrites(s4);
end;

procedure xwritesis;

begin
  xwrites(s1);
  xwritei(i2);
  xwrites(s3);
end;

procedure xwritessis;

begin
  xwritess(s1,s2);
  xwritei(i3);
  xwrites(s4);
end;

procedure xwriteln;

begin
  if console then
    begin
      mousehide;
      writeln;
      mouseshow;
    end
  else
    xwritess(chr(13),chr(10));
end;

procedure xwritelns;

begin
  xwrites(s);
  xwriteln;
end;

procedure xwritelnss;

begin
  xwrites(s1);
  xwrites(s2);
  xwriteln;
end;

procedure xwritelnsss;

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
  xwriteln;
end;

procedure xwritelnssss;

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
  xwrites(s4);
  xwriteln;
end;

procedure xwritelnsi;

begin
  xwrites(s1);
  xwritei(i2);
  xwriteln;
end;

{
procedure xwritelnsssisis;

begin
  xwritesss(s1,s2,s3);
  xwritei(i4);
  xwrites(s5);
  xwritei(i6);
  xwritelns(s7);
end;
}

procedure xgotoxy;

begin
  if console then
    begin
      mousehide;
      gotoxy(x,y);
      mouseshow;
    end
  else
    begin
      xwritess(esc,'[');
      xwritei(y);
      xwrites(';');
      xwritei(x);
      xwrites('f');
    end;
end;

procedure writexy;

begin
  xgotoxy(x,y);
  xwrites(s);
end;

procedure xclreol;

begin
  if console then
    begin
      mousehide;
      clreol;
      mouseshow;
    end
  else
    xwritess(esc,'[0K');
end;

procedure xclreolxy;

begin
  xgotoxy(x,y);
  xclreol;
end;

procedure xclrscr;

begin
  if console then
    begin
      mousehide;
      clrscr;
      mouseshow;
    end
  else
    begin
      xwritess(esc,'[2J');
      xgotoxy(1,1);
    end;
end;

function xkeypressed;

var
  result: boolean;

{$ifdef timeout}
  minnow: integer;
{$endif}

begin
  result := false;

  if console then
    begin
{$ifdef mouse}
      if hasmouse then
        result := keypressed or (mousevent.event<>0)
      else
        result := keypressed;
{$else}
      result := keypressed;
{$endif}
    end
  else
    begin

{check for timeout _before_ checking if a key is ready - modems can spew}

{now also checks for trusted users!  but not on the console}

{$ifdef timeout}

      minnow := mitoday;
      if minnow<minstart then
        inc(minnow,24*60);
      if (minutestorun>=0) and (minnow-minstart>=minutestorun) then
        begin
{$ifdef timeoutreturnscr}
          didtimeout := true;
          result := true;
{$else}
          xwriteln;
          xwritelns('time up');
          xwriteln;
          halt(2);
{$endif}
        end;

      if minnow<minlastinput then
        inc(minnow,24*60);

      if minnow-minlastinput>idleminutes then
        begin
          xwriteln;
          xwritelns('idle timeout');
          xwriteln;
          halt(2);
        end;

{$endif}

{$ifdef mouse}
      if hasmouse then
        result := noncinready or keypressed or (mousevent.event<>0)
      else
        result := noncinready or keypressed;
{$else}
      result := noncinready or keypressed;
{$endif}

    end;

{$ifdef timeout}
  if result then
    minlastinput := mitoday;
{$endif}

  xkeypressed := result;
end;

function xreadkeyextended;

var
  result: char;

{$ifdef mouse}
  regs: registers;
  wasx, wasy: byte;
  newx, newy: byte;
{$endif}

begin
  if console then
    begin

{ ignore function keys, alt keys, numeric pad keys - translate to ' ' }

      repeat

{$ifdef mouse}

        repeat
        { nothing - we're on the console }
        until xkeypressed;

        if keypressed then
          begin
            result := readkey;
          end
        else
          begin
            wasx := wherex;
            wasy := wherey;

            newx := 1+(mousevent.horiz div 8);
            newy := 1+(mousevent.vert div 8);

            if (newy>=beginrow) and (newy<=endrow) then
              newx := 1;

            if forcecolumn<>0 then
              newx := forcecolumn;
            if forcerow<>0 then
              newy := forcerow;

            gotoxy(newx,newy);

{read character from screen}
            regs.ah := 8;
            regs.bh := 0;
            intr($10,regs);

            result := chr(regs.al);

            gotoxy(wasx,wasy);
            mousevent.event := 0;
          end;

{$else}

        result := readkey;

{$endif}

        if (result=#0) and keypressed then
          begin
            result := readkey;

{ change these extended keys: }

{    2nd Char key pressed    code returned       }
{    -------- -----------    -------------       }
{    I  73    PgUp           <                   }
{    Q  81    PgDn           space (or >)        }
{    G  71    Home           ^A (or ^)           }
{    O  79    End            ^E (or $)           }
{    ;  59    F1             ?                   }
{    K  75    left arrow     ^B (or backspace)   }
{    M  77    right arrow    ^F                  }
{    H  72    up arrow       ^P                  }
{    P  80    down arrow     ^N                  }
{    S  83    del            ^D                  }
{    $  36    alt-J          !                   }

            if result='I' then
              result := '<'
            else if result='Q' then
{$ifdef pgdnbecomesgt}
              result := '>'
{$else}
              result := ' '
{$endif}
            else if result='G' then
{$ifdef homebecomescarat}
              result := '^'
{$else}
              result := ^A
{$endif}
            else if result='O' then
{$ifdef endbecomesdollar}
              result := '$'
{$else}
              result := ^E
{$endif}
            else if result=';' then
              result := '?'
            else if result='K' then
{$ifdef leftbecomesbackspace}
              result := #8
{$else}
              result := ^B
{$endif}
            else if result='M' then
              result := ^F
            else if result='H' then
              result := ^P
            else if result='P' then
              result := ^N
            else if result='S' then
              result := ^D
            else if result='$' then
              result := '!'
            else

{ ignore other extended keys }

              result := #0;

          end;

      until result<>#0;
    end
  else
    begin
      while not xkeypressed do
        ;
      if keypressed then
        result := readkey
      else
        result := noncreadc;
    end;
  xreadkeyextended := mainmap[result];
end;

function xreadkey;

begin
  xreadkey := xreadkeyextended(0,0,0,0);
end;

procedure xreadlnseh;  {readln, can end with some non-RETURN keys, history}

{acceptable lists are RETURN plus some of LF, SPACE, TAB, ESC}

{readlnhistoryp can be nil to indicate no history}

var
  result: string;
  done: boolean;

  len: integer;        {the length of the string}
  position: integer;   {the position in the string, or len+1}
  onekey: char;        {one key from the keyboard}
  tempint: integer;

begin
  if keepcurrent then
    result := s
  else
    result := '';

  len := length(result);
  xwrites(result);
  position := len+1;  {+1 since we're appending at the end}

  done := false;

  while not done do
    begin
      onekey := xreadkey;
      if (onekey=#127) or (onekey=#8) then  {backspace}
        begin
          if position>1 then
            begin
              dec(position);
              dec(len);
              if len=0 then
                result := ''
              else
                result :=
                 copy(result,1,position-1)+copy(result,position+1,255);

              xwrites(^H);
              xclreol;
              xwrites(copy(result,position,255));
              for tempint := 0 to (len-position) do
                xwrites(^H);
            end;
        end
      else if onekey=^D then  {delete}
        begin
          if position<=len then
            begin
              dec(len);
              if len=0 then
                result := ''
              else
                result :=
                 copy(result,1,position-1)+copy(result,position+1,255);

              xclreol;
              xwrites(copy(result,position,255));
              for tempint := 0 to (len-position) do
                xwrites(^H);
            end;
        end
      else if onekey=^B then  {back a character}
        begin
          if position>1 then
            begin
              xwrites(#8);
              dec(position);
            end;
        end
      else if onekey=^F then  {forward a character}
        begin
          if position<len+1 then
            begin
              if position<=len then
                xwrites(copy(result,position,1));
              inc(position);
            end;
        end
      else if onekey=^A then  {beginning}
        begin
          for tempint := position-1 downto 1 do
            begin
              xwrites(#8);
              dec(position);
            end;
        end
      else if onekey=^E then  {end}
        begin
          for tempint := position+1 to len+1 do
            begin
              xwrites(copy(result,position,1));
              inc(position);
            end;
        end
      else if pos(onekey,endlist)<>0 then  {finished}
        begin
{$ifdef xwritelnafterxreadln}
          xwriteln;
{$endif}
          done := true;
        end
      else if onekey=^U then  {erase it all}
        begin
          for tempint := 1 to position-1 do
            xwrites(^H);
          xclreol;
          result := '';
          len := 0;
          position := 1;
        end
      else if (ord(onekey)>=32) and (eightbitclean or (ord(onekey)<128))
       and (len<maxlen) then  {insert a character}
        begin
          inc(len);
          result := copy(result,1,position-1)+onekey+copy(result,position,255);

          xwrites(copy(result,position,255));
          inc(position);
          for tempint := 0 to (len-position) do
            xwrites(^H);
        end;
    end;

  s := result;
end;

procedure xreadlnse;

{acceptable lists are RETURN plus some of LF, SPACE, TAB, ESC}

begin
  xreadlnseh(s,maxlen,keepcurrent,endlist,nil);
end;

procedure xreadlns;

begin
  xreadlnse(s,maxlen,keepcurrent,endkeysnospace);
end;

procedure xsetcolor;

{color is 0-15, background is 0-7}

begin
  if console then
    begin
      textcolor(color and $f);
      textbackground(color shr 4);
    end
  else if color=highcolor then
    xwritess(esc,'[7m')
  else
    xwritess(esc,'[m');
end;

procedure xhighvideo;

begin
  xsetcolor(highcolor);
end;

procedure xlowvideo;

begin
  xsetcolor(lowcolor);
end;

procedure xwritehighlights;

var
  i: integer;

begin
  for i := 1 to length(s) do
    if s[i]='{' then
      xhighvideo
    else if s[i]='}' then
      xlowvideo
    else
      xwrites(s[i]);
end;

procedure hwritexy;

begin
  xgotoxy(x,y);
  xwritehighlights(s);
end;

end.